home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Delphi Programmer's Power Pack
/
Delphi Volume 1.iso
/
s_to_z
/
statone
/
dynary.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-09-15
|
7KB
|
280 lines
unit dynary;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs;
const
MAX_SIZE = 8000;
VERSION = 'Ver 0.3';
type
CompFunc = Function(V1,V2:Pointer):Boolean;
TElement = Double;
TIndex = WORD;
PElement = ^TElement;
TTheArray = Array[1..MAX_SIZE] of TElement;
PArray = ^TTheArray;
TDoubleArray = class(TComponent)
private
{ Private declarations }
FAbout: string;
FSize: TIndex;
FArray: TTheArray;
FArrayPtr: PArray;
FArrayAssigned: Boolean;
PROCEDURE SetArrayValue(idx: TIndex; CONST NewElement: TElement);
FUNCTION GetArrayValue(idx: TIndex): TElement;
PROCEDURE CreateArray(CONST Size: TIndex);
PROCEDURE DestroyArray;
PROCEDURE InitializeArrayElements(CONST LoInit, HiInit:TIndex);
procedure SetAbout(value: string);
protected
public
property Value[idx: TIndex]: TElement read GetArrayValue write SetArrayValue; default;
procedure Sort;
{property AddrOfElement[idx: TIndex]: PElement read GetElementAddress;}
published
property Size: TIndex read FSize write FSize;
FUNCTION CheckRange(CONST N: TIndex):BOOLEAN;
FUNCTION SetSize(Size: TIndex): BOOLEAN;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property About: string read FAbout write SetAbout;
end;
Procedure SortProcedure(Var Struct; { array of any Type }
Num, { Number of elements }
ElementSize:Integer; { Size of each element ( byte ) }
Comp:CompFunc); { Type of compare function to use}
Function IntComp(I1,I2:Pointer):Boolean; far;
Function SingleComp(r1,r2:Pointer):Boolean; far;
Function RealComp(r1,r2:Pointer):Boolean; far;
Function DoubleComp(r1,r2:Pointer):Boolean; far;
Function ByteComp(b1,b2:Pointer):Boolean; far;
Function CharComp(c1,c2:Pointer):Boolean; far;
Function StringComp(s1,s2:Pointer):Boolean;far;
procedure register;
{===========================================}
implementation
CONSTRUCTOR TDoubleArray.Create(AOwner: TComponent);
BEGIN
inherited Create(AOwner);
FAbout := VERSION;
IF FSize > 0 THEN
CreateArray(Size)
ELSE
FArrayAssigned := FALSE;
FSize := 0;
END;
DESTRUCTOR TDoubleArray.Destroy;
BEGIN
DestroyArray;
inherited Destroy;
END;
PROCEDURE TDoubleArray.InitializeArrayElements (CONST LoInit, HiInit: TIndex);
VAR
idx: TIndex;
BEGIN
FOR idx := LoInit TO HiInit DO
FArrayPtr^[idx] := 0.0;
END;
PROCEDURE TDoubleArray.CreateArray(CONST Size: TIndex);
BEGIN
GetMem(FArrayPtr, Size * SizeOf(TElement));
FSize := Size;
InitializeArrayElements(1, FSize);
FArrayAssigned := TRUE
END;
PROCEDURE TDoubleArray.DestroyArray;
BEGIN
FreeMem(FArrayPtr, FSize * SizeOf(TElement));
FArrayAssigned := FALSE;
END;
FUNCTION TDoubleArray.CheckRange(CONST N: TIndex): BOOLEAN;
BEGIN
IF (N > FSize) OR (N < 1) THEN
Result := FALSE
ELSE
Result := TRUE;
END;
PROCEDURE TDoubleArray.SetArrayValue(idx: TIndex; CONST NewElement: TElement);
BEGIN
FArray[idx] := NewElement;
END;
FUNCTION TDoubleArray.GetArrayValue(idx: TIndex): TElement;
BEGIN
Result := FArray[idx];
END;
FUNCTION TDoubleArray.SetSize(Size: TIndex): BOOLEAN;
BEGIN
{CHECK THE RANGE}
IF (Size > MAX_SIZE) OR (Size < 1) THEN
BEGIN
Result := FALSE;
Exit;
END;
{SET THE SIZE}
IF FArrayAssigned = FALSE THEN
CreateArray(Size)
ELSE
begin
{REALLOCATE ARRAY ROUTINE HERE}
FreeMem(FArrayPtr, FSize * SizeOf(TElement));
FArrayAssigned := FALSE;
CreateArray(Size)
end;
END;
procedure TDoubleArray.Sort;
begin
if FSize > 1 then
SortProcedure(FArray, FSize, 8, DoubleComp);
end;
Procedure SortProcedure{...};
var
Temp:Pointer;
StructBase:Array[0..0] of Byte Absolute Struct;
Function VLoc(n:integer):Pointer;
{ Note that no range check is performed! }
Begin
{$R-}
VLoc:=Addr(structBase[n*ElementSize]);
{$R+}
End;
Procedure Swap(n1,n2:Integer);
{ swap two elements }
Begin
Move(VLoc(n1)^,Temp^,ElementSize);
Move(VLoc(n2)^,VLoc(n1)^,ElementSize);
Move(Temp^,VLoc(n2)^,ElementSize);
End;
{ Quick sort routine }
Procedure Qsort(l,r:Integer);
Var
i,j:Integer;
Pivot:Pointer;
Begin
i:=l;
j:=r;
GetMem(Pivot,ElementSize); { Hopefully, the midpoint}
Move(Vloc((L+r) div 2)^,Pivot^,ElementSize);
Repeat
while Comp(Pivot,Vloc(i)) do inc(i);
while Comp(Vloc(J),pivot) do Dec(j);
if i<=j then
Begin
Swap(i,j);
Inc(i);
Dec(j);
End;
until i>j;
if j>l then Qsort(l,j); { recoursive call }
if i<r then Qsort(i,r);
FreeMem(Pivot,ElementSize);
End;
begin
GetMem(Temp,ElementSize); { Temp is used for swap }
if num>1 then
Qsort(0,Num-1);
FreeMem(Temp,ElementSize);
end;
Function IntComp(I1,I2:Pointer):Boolean;
Type
IntPtr=^Integer;
Var
v1:IntPtr absolute I1;
v2:IntPtr absolute I2;
Begin
IntComp:=V1^>V2^;
End;
Function SingleComp(r1,r2:Pointer):Boolean;
Type
SinglePtr=^Single;
Var
v1:SinglePtr absolute r1;
v2:SinglePtr absolute r2;
Begin
SingleComp:=V1^>V2^;
End;
Function RealComp(r1,r2:Pointer):Boolean;
Type
RealPtr=^Real;
Var
v1:RealPtr absolute r1;
v2:RealPtr absolute r2;
Begin
RealComp:=V1^>V2^;
End;
Function DoubleComp(r1,r2:Pointer):Boolean;
Type
DoublePtr=^Double;
Var
v1:DoublePtr absolute r1;
v2:DoublePtr absolute r2;
Begin
DoubleComp:=V1^>V2^;
End;
Function ByteComp(b1,b2:Pointer):Boolean;
Type
BytePtr=^Byte;
Var
v1:BytePtr absolute b1;
v2:BytePtr absolute b2;
Begin
ByteComp:=V1^>V2^;
End;
Function CharComp(c1,c2:Pointer):Boolean;
Begin
CharComp:=ByteComp(c1,c2); { Byte and char are the same! }
End;
Function StringComp(s1,s2:Pointer):Boolean;
Type
StringPtr=^String;
Var
v1:StringPtr absolute s1;
v2:StringPtr absolute s2;
Begin
StringComp:=V1^>V2^;
End;
procedure TDoubleArray.SetAbout(value: string);
begin
FAbout := VERSION;
end;
PROCEDURE Register;
BEGIN
RegisterComponents('Ted', [TDoubleArray]);
END;
end.